home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / System source / StrUtilities < prev    next >
Text File  |  1994-06-28  |  7KB  |  330 lines
  1. \ Utility subroutines for the String+ class.
  2. \ Separated from String+ and revised - Aug 87.
  3. \ Error checking improved - May 88.
  4. \ Version for Mops - June 89.
  5.  
  6.     0    value    CASE?        \ True if case to be significant in comparisons
  7.  
  8.   $ D    constant    RET        \ Carriage return
  9.     0    value        $START    \ Addr of start of (chars of) current string.
  10.  
  11.  
  12. \        ========  TRTBL class  ========
  13.  
  14. \ Translate tables allow very fast searching of strings for specified sets
  15. \ of characters.  In effect we are separating the specification of what we
  16. \ are searching for from the actual search operation itself.  This allows an
  17. \ uncluttered and extremely fast search operation (the SCAN: and <SCAN: methods
  18. \ of class STRING+), and it also allows a very flexible (and easily extensible)
  19. \ choice of what to search for.  The setup time for translate tables can
  20. \ generally be factored out of inner loops, or done at compile time, and is
  21. \ quite fast, anyway.
  22. \ We first define a class (trtbl) which is needed to define the table mapping
  23. \ lower case letters to upper case.  This table is then used by some of
  24. \ the methods in the trtbl class proper.
  25.  
  26. :class (TRTBL)  super{ object }
  27.  
  28. record
  29. {        int        COUNT
  30.     256    bytes    THETBL
  31. }
  32.  
  33. :m TBL:  addr: theTbl  ;m
  34.  
  35. :m >UC:
  36.     addr: theTbl  & A  +
  37.     addr: theTbl  & a  +
  38.     26  cmove  ;m
  39.  
  40. :mcode TRANSC:    \ ( c -- c' )  Translates 1 char using the table.
  41.     MOVE    (SP),D0
  42.     MOVE.B    2(A2,D0.W),3(SP)
  43. ;mcode
  44.  
  45. ;class
  46.  
  47.  
  48. (trtbl) UCTBL        \ Maps lower case letters to upper case, and
  49.                     \  leaves everything else unchanged.
  50.  
  51. : XX
  52.     0   tbl: UCtbl  256  bounds
  53.     DO  dup i c!  1+  LOOP
  54.     drop  >uc: UCtbl  ;
  55.  
  56. xx  forget xx
  57.  
  58. :code (SELC)        \ Subroutine used by SELCHAR: and SELCHARNC:.
  59.     ADDQ.W    #1,(A2)
  60.     MOVE.W    (A2)+,D1
  61.     MOVE.B    D1,0(A2,D2.W)
  62. ;code
  63.  
  64.  
  65. :class TRTBL  super{ (trtbl) }
  66.  
  67. :mcode CLEAR:
  68.     loc
  69.     CLR.W    (A2)+
  70.     MOVEQ    #63,D0
  71. loop    CLR    (A2)+
  72.     DBRA    D0,loop
  73. ;mcode
  74.  
  75.  
  76. :m PUT:  { addr len -- }
  77.     addr  addr: theTbl  len 256 min  cmove  ;m
  78.  
  79.  
  80. :mcode SELCHARS:    \ ( addr len -- )
  81.     loc
  82.     POP    D0        ; D0 = len
  83.     POP    A1        ; A1 = addr
  84.     ADD    D0,A1
  85.     MOVE    D0,D1
  86.     ADD.W    (A2),D1
  87.     MOVE.W    D1,(A2)+
  88.     MOVEQ    #0,D2
  89.     BRA.S    lptst
  90.  
  91. loop    MOVE.B    -(A1),D2
  92.     MOVE.B    D1,0(A2,D2.W)
  93.     SUBQ    #1,D1
  94. lptst    DBRA    D0,loop
  95. ;mcode
  96.  
  97.  
  98. :mcode SELCHAR:        \ ( c -- )
  99.     POP    D2
  100.     BSR    dic[(selc)]
  101. ;mcode
  102.  
  103.  
  104. :mcode SELCHARNC:    \ ( c -- )  "SelChar, no case".
  105.         \ Selects a character, and if it is a letter,
  106.         \ enters the same value in the LC and UC positions of the
  107.         \ table, so that case will in effect be ignored when the
  108.         \ table is used.
  109.     POP    D2
  110.     LEA    10(dic[UCtbl]),A0    ; Offset is offs to ^obj, plus 2
  111.     MOVE.B    0(A0,D2.W),D2        ; Convert char to upper case
  112.     BSR    dic[(selc)]
  113.     CMPI.B    #$41,D2
  114.     BLT.S    end
  115.     CMPI.B    #$5A,D2
  116.     BGT.S    end
  117.     ORI.B    #$20,D2
  118.     MOVE.B    D1,0(A2,D2.W)
  119. end
  120. ;mcode
  121.     
  122. :mcode SELRANGE:    \ ( lo hi -- )
  123.     loc
  124.     ADDQ    #2,A2
  125.     POP    D0        ; hi
  126.     POP    D1        ; lo
  127.     ADD    D1,A2
  128.     SUB    D1,D0
  129.     BLT.S    end
  130.     MOVEQ    #1,D2
  131.  
  132. loop    MOVE.B    D2,(A2)+
  133. lptst    DBRA    D0,loop
  134. end
  135. ;mcode
  136.  
  137. :mcode INVERT:
  138.     loc
  139.     ADDQ    #2,A2
  140.     MOVEQ    #255,D0
  141. loop    TST.B    (A2)
  142.     SEQ    (A2)+
  143.     DBRA    D0,loop
  144. ;mcode
  145.  
  146. ;class
  147.  
  148.  
  149. \ GETIT is a code subroutine to get the address and length of the active part
  150. \ of the current string.  A2 points to the string object.
  151. \
  152. \ Returns:
  153. \    A0    addr of first char of the active part
  154. \    D0    length of active part
  155. \    D2 (lo half)  high 16 bits of length - may be used as an outer loop
  156. \               counter in DBxx loops.
  157. \    CC    result of subtracting POS from LIM to get the length.
  158. \     $start    addr of the start of the whole string
  159. \
  160. \ If this length turns out to be negative, $CHK is called to give an error trap.
  161. \ We don't take a length of zero as an error (there are some situations where
  162. \ this is quite legitimate).  Those operations which don't like a zero
  163. \ length can call $CHK themselves.
  164. \ This subroutine must be called from a method, with A2 undisturbed.
  165. \ Only A0, A2, D0 and D2 are altered.
  166.  
  167. :code GETIT
  168.     loc
  169.     MOVE    (A2),A0    ; A0 = handle
  170.     MOVE    (A0),A0    ; Dereference it - addr of start of string
  171.     MOVE    A0,dic[$start]    ; Leave in $start
  172.     ADD    8(A2),A0    ; Add POS, giving addr of start of active part
  173.     MOVE    12(A2),D0    ; D0 = LIM
  174.     SUB    8(A2),D0    ; Subtract POS, giving length
  175.     MOVE    D0,D2
  176.     SWAP    D2    ; Hi 16 bits to lo half of D2
  177.     TST    D0    ; Test length
  178.     BGE.S    end
  179.     JMP    dic[$fail]    ; If negative, error
  180. end
  181. ;code
  182.  
  183.  
  184. \ CCMP is the primitive subroutine for performing string comparison.
  185. \    A0 -> string2
  186. \    A1 -> string1
  187. \    D0 = length
  188. \ Assumes length is less than 64K.
  189. \ Returns with the CC set appropriately.
  190. \ Uses those registers.
  191.  
  192. :code CCMP
  193.     loc
  194.     SUBQ    #1,D0
  195.     BMI.S    equal
  196.     TST    dic[case?]
  197.     BEQ.S    nocase
  198.  
  199. loop1    CMPM.B    (A0)+,(A1)+
  200.     DBNE    D0,loop1
  201.     RTS
  202.  
  203. equal    CMP.W    D0,D0
  204.     RTS
  205.  
  206. nocase    MOVEM    D2/D3/A2,-(SP)
  207.     MOVEQ    #0,D2
  208.     LEA    10(dic[UCtbl]),A2
  209.  
  210. loop2    CMPM.B    (A0)+,(A1)+
  211. lp2tst    DBNE    D0,loop2
  212.     BEQ.S    end
  213.     MOVE.B    -1(A1),D2
  214.     MOVE.B    0(A2,D2.W),D3
  215.     MOVE.B    -1(A0),D2
  216.     CMP.B    0(A2,D2.W),D3
  217.     BEQ.S    lp2tst
  218. end    MOVEM    (SP)+,D2/D3/A2
  219. ;code
  220.  
  221.  
  222. \ CSCH and <CSCH are the primitive subroutines for searching for a single
  223. \ character.
  224. \    A0 -> string
  225. \    D0 = length
  226. \    D2 = length (hi)
  227. \    D1 = char (rest must be zero)
  228. \ Both routines return with the CC set appropriately.
  229.  
  230. :code CSCH
  231.     loc
  232.     TST    dic[case?]
  233.     BEQ.S    nocase
  234.     BRA.S    lp1tst    ; Note: we enter the loop with "not equal"
  235.  
  236. loop1    CMP.B    (A0)+,D1
  237. lp1tst    DBEQ    D0,loop1
  238.     DBEQ    D2,loop1
  239.     RTS
  240.  
  241. nocase    MOVEM    D1/D2/A2,-(SP)
  242.     LEA    10(dic[UCtbl]),A2
  243.     MOVE.B    0(A2,D1.W),D1
  244.     MOVEQ    #1,D2    ; Set "not equal", clear top 3 bytes of D2
  245.     BRA.S    lp2tst
  246.  
  247. outer    MOVE    D2,4(SP)
  248. loop2    MOVE.B    (A0)+,D2
  249.     CMP.B    0(A2,D2.W),D1
  250. lp2tst    DBEQ    D0,loop2
  251.     MOVEM    4(SP),D2    ; Recover outer loop counter, preserving CC
  252.     DBEQ    D2,outer
  253.     MOVEM    (SP)+,D1/D2/A2
  254. end
  255. ;code
  256.  
  257. :code <CSCH
  258.     loc
  259.     TST    dic[case?]
  260.     BEQ.S    nocase
  261.     BRA.S    lp1tst        ; Note: we enter the loop with "not equal"
  262.  
  263. loop1    CMP.B    -(A0),D1
  264. lp1tst    DBEQ    D0,loop1
  265.     DBEQ    D2,loop1
  266.     BRA.S    end
  267.  
  268. nocase    MOVEM    D1/D2/A2,-(SP)
  269.     LEA    10(dic[UCtbl]),A2
  270.     MOVE.B    0(A2,D1.W),D1
  271.     MOVEQ    #1,D2        ; Set "not equal", clear top 3 bytes of D2
  272.     BRA.S    lp2tst
  273.  
  274. outer    MOVE    D2,4(SP)
  275. loop2    MOVE.B    -(A0),D2
  276.     CMP.B    0(A2,D2.W),D1
  277. lp2tst    DBEQ    D0,loop2
  278.     MOVEM    4(SP),D2    ; Recover outer loop counter, preserving CC
  279.     DBEQ    D2,outer
  280.     MOVEM    (SP)+,D1/D2/A2
  281. end
  282. ;code
  283.  
  284.  
  285. \ CMPSTR ( addr1 len1 addr2 len2 -- n ) compares 2 strings.
  286. \ Case is significant if CASE? is set to true.
  287. \ Returns:
  288. \  -1   first string low
  289. \   0   strings are equal
  290. \   1   first string high
  291. \ We assume the lengths are both less than 64K.
  292. \
  293. \ Uses D0,D1,D2,A0,A1.
  294.  
  295. :code CMPSTR
  296.     loc
  297.     POP    D0        ; D0 = len2
  298.     POP    A0        ; A0 = addr2
  299.     POP    D1        ; D1 = len1
  300.     MOVE    (SP),A1        ; A1 = addr1
  301.     MOVEQ    #0,D2        ; D2 will hold return result
  302.     CMP.W    D1,D0        ; Compare lengths
  303.     BEQ.S    docmp
  304.     BHI.S    op2long
  305.     MOVEQ    #1,D2
  306.     BRA.S    docmp
  307.  
  308. op2long    MOVE.W    D1,D0
  309.     MOVEQ    #-1,D2
  310.  
  311. docmp    BSR    dic[ccmp]
  312.     BEQ.S    end
  313.     SMI    D2
  314.     ORI.B    #1,D2
  315.     EXT.W    D2
  316.     EXT.L    D2
  317. end    MOVE    D2,(SP)
  318. ;code
  319.  
  320.  
  321. \ INSTEAD ( c-old c-new -- )  may be used just after a SCON is defined.
  322. \ Within the SCON, it replaces any occurrences of c-old with c-new.  This 
  323. \ operation is useful for creating SCONs containing special characters
  324. \ such as tab.
  325.  
  326. : INSTEAD  { c-old c-new -- }
  327.     latest name> ex-gen  bounds    \ SCONs use DOES> so require EX-GEN
  328.     DO   i c@ c-old = IF  c-new i c!  THEN
  329.     LOOP  ;
  330.